perm filename MET14.LSP[TIM,LSP] blob sn#715199 filedate 1983-06-16 generic text, type C, neo UTF8
COMMENT āŠ—   VALID 00003 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	(declare 
C00008 00003
C00009 ENDMK
CāŠ—;
(declare 
 (fasload meter)
 (load "metint.lsp")
 (setq meter:count-only T))
(declare 
 (setq local-objects-of-interest 
       '((mapcan "Mapcans")(funcall "Funcalls")
			   (mapc "Mapcs")
			   (list "Lists")(list* "List*s"))))

(meter:meter sccpp
 (meter-funs #.(all-objs)
(DEFUN PAIRS (X Y MUST-APPEAR FUN APPLY-CONSTRAINTS CONSTRAINTS
	      NIL-PAIRS) 
 (mn "PAIR" pair)
       ((LAMBDA (XXX) 
	 (MAPCAN 
	  #'(LAMBDA (I) 
             (AND
	       (COND
		(MUST-APPEAR
		 (MN "Catches" catch)
		 (*CATCH 'OUT
		   (MAPC 
		    #'(LAMBDA (I) (COND ((MEMBER (CDR I) MUST-APPEAR)
					 (MN "Throws" throw)
					 (*THROW 'OUT T)))) 
		   I)))
		(T))
	       (LIST I)))
	  XXX)) 
	(MAPCAR #'CDR
		(COND ((< (LENGTH X)
			  (+ (COND (NIL-PAIRS 1) (T 0)) (LENGTH Y)))
		       (PAIRS1 (MAKE-POSSIBILITY-1 X
						   Y
						   FUN
						   APPLY-CONSTRAINTS
						   CONSTRAINTS
						   NIL-PAIRS)))
		      (T (PAIRS2 (MAKE-POSSIBILITY-2 Y
						     X
						     FUN
						     APPLY-CONSTRAINTS
						     CONSTRAINTS
						     NIL-PAIRS)))))))


(DEFUN MAKE-POSSIBILITY-1 (X Y FUN APPLY-CONSTRAINTS CONSTRAINTS
			   NIL-PAIRS) 
 (mn "MAKE-POSSIBILITY-1" mp1)
       ((LAMBDA (N) 
	 ((LAMBDA (Q) 
	   (COND
	    (NIL-PAIRS (MAPC #'(LAMBDA (I) (RPLACD I
						   (LIST* '(NIL)
							  (CDR I))))
			     Q))
	    (T Q)))
	  (MAPCAN 
	   #'(LAMBDA (I) 
		     (SETQ N 0)
		     ((LAMBDA (A) (AND A
				       (OR (NULL CONSTRAINTS)
					   (NULL APPLY-CONSTRAINTS)
					   (FUNCALL APPLY-CONSTRAINTS
						    CONSTRAINTS))
				       (LIST (LIST* I A))))
		(MAPCAN 
		 #'(LAMBDA (J) ((LAMBDA (Q) (COND (Q (NCONS Q))))
				(PROGN (SETQ N (1+ N))
				       (COND ((OR (NULL FUN)
						  (FUNCALL FUN I J))
					      (LIST* N J))))))
		 Y)))
  	   X)))
	0))


(DEFUN MAKE-POSSIBILITY-2 (X Y FUN APPLY-CONSTRAINTS CONSTRAINTS
			   NIL-PAIRS) 
 (mn "MAKE-POSSIBILITY-2" mp2)
       ((LAMBDA (N) 
	 ((LAMBDA (Q) 
	   (COND
	    (NIL-PAIRS (MAPC #'(LAMBDA (I) (RPLACD I
						   (LIST* '(NIL)
							  (CDR I))))
			     Q))
	    (Q)))
	  (MAPCAN 
	   #'(LAMBDA (I) 
	       (SETQ N 0)
	       ((LAMBDA (A) (AND A
				 (OR (NULL CONSTRAINTS)
				     (NULL APPLY-CONSTRAINTS)
				     (FUNCALL APPLY-CONSTRAINTS
					      CONSTRAINTS))
				 (LIST (LIST* I A))))
		(MAPCAN 
		 #'(LAMBDA (J) ((LAMBDA (Q) (COND (Q (NCONS Q))))
				(PROGN (SETQ N (1+ N))
				       (COND ((OR (NULL FUN)
						  (FUNCALL FUN J I))
					      (LIST* N J))))))
		 Y)))
	   X)))
	0))


(DEFUN PAIRS1 (L) 
 (mn "PAIRS1" pairs1)
       (COND
	((NULL L) '((NIL)))
	(T
	 ((LAMBDA (CAND POSS) 
	   (MAPCAN 
	    #'(LAMBDA (PAIRS) 
		((LAMBDA (AVOID ANS) 
		  (MAPCAN 
		   #'(LAMBDA (I) 
			     ((LAMBDA (Q) (COND (Q (NCONS Q))))
			      (COND ((CAR (MEMBER (CAR I)
						  AVOID))
				     (LIST* AVOID ANS))
				    (T (LIST* (LIST* (CAR I)
						     AVOID)
					      (LIST* CAND
						     (CDR I))
					      ANS)))))
		   POSS))
		 (CAR PAIRS)
		 (CDR PAIRS)))
	    (PAIRS1 (CDR L))))
	  (CAAR L)
	  (progn
	   (mn "Cars" car 1)
	   (mn "Cdrs" cdr 1)
	  (CDAR L))))))


(DEFUN PAIRS2 (L) 
 (mn "PAIRS1" pairs1)
       (COND
	((NULL L) '((NIL)))
	(T
	 ((LAMBDA (CAND POSS) 
	   (MAPCAN 
	    #'(LAMBDA (PAIRS) 
		((LAMBDA (AVOID ANS) 
		  (MAPCAN 
		   #'(LAMBDA (I) 
			     ((LAMBDA (Q) (COND (Q (NCONS Q))))
			      (COND ((CAR (MEMBER (CAR I)
						  AVOID))
				     (LIST* AVOID ANS))
				    (T (LIST* (LIST* (CAR I)
						     AVOID)
					      (LIST* (CDR I)
						     CAND)
					      ANS)))))
		   POSS))
		 (CAR PAIRS)
		 (CDR PAIRS))) 
	    (PAIRS2 (CDR L))))
	  (CAAR L)
	  (progn
	   (mn "Cars" car 1)
	   (mn "Cdrs" cdr 1)
	  (CDAR L))))))))

(declare (special a b))
(setq a '(
	  (1 2)
	  (7 8)
	  (9 0)
	  (a b c)
	  (a b c)
	  (d e f)
	  (d e f)
	  (g h i)
	  (g h i)
	  (j k l)
	  (m n o)
	  (p q r)
	  ))
(setq b '(
	  (a b c)
	  (j k l)
	  (d e f)
	  (p q r)
	  (g h i)
	  (9 0)
	  (a b c)
	  (p q r)
	  (7 8)
	  (j k l)
	  (2 1)
	  (3 2)
	  (8 7)
	  (9 8)
	  (0 9)
	  (m n o)
	  (d e f)
	  (j k l)
	  (m n o)
	  (d e f)
	  (p q r)
	  (g h i)
	  ))